Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue63/Debug/HVBordebug/BorDebugScanners.pas

Pascal/Delphi Source File | 2000-10-02 | 16.0 KB | 444 lines

unit BorDebugScanners;

interface

uses
  BorDebug,
  HVBorDebug
  ;

type
  // TCustomBorDebugScanner is a class to help in scanning the debug info
  // from start to end. To use, inherit from it and override the methods
  // you are interested in.
  TScanningOption = (soModule, soAlignSym, soSrcModule, soGlobalSym, soGlobalPub,
    soGlobalTypes, soNames, soBrowse, soSrcModuleRanges, soSrcModuleFiles);

  TScanningOptions = set of TScanningOption;
  TCustomBorDebugScanner = class(TObject)  // TObject!
  private
    FBorDebug: TBorDebug;
    FScanningOptions: TScanningOptions;

    FCurrentSourceFileEntry: TSourceFileEntry;
    FCurrentLineNumberOffsets: TLineNumberOffsets;
    FCurrentSubSection: PBorDebugSubSection;
    FCurrentModule: TBorDebugModule;
    FCurrentSrcModule: TBorDebugSrcModule;
  protected
    procedure ScanSymbolTypeNode(const SubSection: TBorDebugSubSection;
      SymbolInfo: TSymbolInfo; BorDebugType: TBorDebugType);
    procedure ScanSymbolTypeTree(const SubSection: TBorDebugSubSection;
      SymbolInfo: TSymbolInfo; TypeIndex: TTypeIndex);

    function WantType(const BorDebugType: TBorDebugType): boolean; virtual;
    function WantSymbol(const Symbol: TBorDebugSymbol): boolean; virtual;
    function WantFieldList(const SubSection: TBorDebugSubSection;
      SymbolInfo: TSymbolInfo; const BorDebugType: TBorDebugType): boolean; virtual;
    function WantTypeInfoForSymbol(SymbolInfo: TSymbolInfo; TypeIndex: TTypeIndex): boolean; virtual;
    procedure StartFieldListScan(const SubSection: TBorDebugSubSection;
      SymbolInfo: TSymbolInfo; BorDebugType: TBorDebugType); virtual;
    procedure EndFieldListScan(const SubSection: TBorDebugSubSection;
      SymbolInfo: TSymbolInfo; BorDebugType: TBorDebugType); virtual;
    procedure ScanLineNumberOffset(LineNumber: TLineNumber;
      LineOffset: TSegmentOffset); virtual;
    procedure ScanSrcModuleSourceRange(RangeIndex: integer;
      Segment: TSegmentIndex; Starts, Ends: TSegmentOffset;
      LineNumberCount: TItemCount; LineNumberOffsets: TLineNumberOffsets); virtual;
    procedure ScanSymbolTypeInfo(const SubSection: TBorDebugSubSection;
      SymbolInfo: TSymbolInfo; TypeInfo: TTypeInfo; var KeepIt: boolean); virtual;
    procedure ScanSrcModule(const SubSection: TBorDebugSubSection;
      SrcModule: TBorDebugSrcModule; var KeepIt: boolean);  virtual;
    procedure ScanSrcModuleRange(const SubSection: TBorDebugSubSection;
      SrcModule: TBorDebugSrcModule; RangeIndex: integer;
      RangeSegmentIndex: TSegmentIndex; RangeStart,
      RangeEnd: TSegmentOffset);  virtual;
    procedure ScanSrcModuleSource(const SubSection: TBorDebugSubSection;
      SrcModule: TBorDebugSrcModule; SourceIndex: integer;
      SourceOffset: TFileOffset; NameIndex: TNameIndex;
      RangeCount: TItemCount; SourceFileEntry: TSourceFileEntry); virtual;
    procedure ScanSymbolInfo(const SubSection: TBorDebugSubSection;
      SymbolInfo: TSymbolInfo; var KeepIt: boolean);  virtual;
    procedure ScanSymbols(const SubSection: TBorDebugSubSection);  virtual;
    procedure ScanModule(const SubSection: TBorDebugSubSection;
      Module: TBorDebugModule; var KeepIt: boolean); virtual;
    procedure ScanModuleSegment(const SubSection: TBorDebugSubSection;
      Module: TBorDebugModule; SegmentIndex: integer; const Segment: TModuleSegment); virtual;
    procedure ScanSubSection(SubSectionIndex: integer; const SubSection: TBorDebugSubSection); virtual;
    procedure ScanSubsections; virtual;
    property CurrentSourceFileEntry: TSourceFileEntry read FCurrentSourceFileEntry;
    property CurrentLineNumberOffsets: TLineNumberOffsets read FCurrentLineNumberOffsets;
    property CurrentSubSection: PBorDebugSubSection read FCurrentSubSection;
    property CurrentModule: TBorDebugModule read FCurrentModule;
    property CurrentSrcModule: TBorDebugSrcModule read FCurrentSrcModule;
    property ScanningOptions: TScanningOptions read FScanningOptions write FScanningOptions;
  public
    constructor Create(ABorDebug: TBorDebug);
    procedure Scan(ScanningOptions: TScanningOptions);
    property BorDebug: TBorDebug read FBorDebug write FBorDebug;
  end;

  TLineNumberScannerTask = (ltMatchAddress, stMatchUnitLinenr);
  TLineNumberScanner = class(TCustomBorDebugScanner)
  private
    FTask : TLineNumberScannerTask;
    FAddress: TSegmentOffset;
    FBestMatch: TSegmentOffset;
    FUnitname: string;
    FLinenumber: TLinenumber;
    FFoundMatch: boolean;
  protected
    procedure ScanLineNumberOffset(LineNumber: TLineNumber; LineOffset: TSegmentOffset); override;
  public
    function FindUnitnameLinenumber(Address: TSegmentOffset; out Unitname: string; out Linenumber: TLinenumber): boolean;
  end;

implementation

uses
  SysUtils;

{ Utility routines }

function SubsectionTypeToScanningOption(SubsectionType: TSubsectionType): TScanningOption;
begin
   case SubsectionType of
      BORDEBUG_SSTMODULE      : Result := soModule;
      BORDEBUG_SSTALIGNSYM    : Result := soAlignSym;
      BORDEBUG_SSTSRCMODULE   : Result := soSrcModule;
      BORDEBUG_SSTGLOBALSYM   : Result := soGlobalSym;
      BORDEBUG_SSTGLOBALPUB   : Result := soGlobalPub;
      BORDEBUG_SSTGLOBALTYPES : Result := soGlobalTypes;
      BORDEBUG_SSTNAMES       : Result := soNames;
      BORDEBUG_SSTBROWSE      : Result := soBrowse;
   else                         raise Exception.Create('Unexpected SubSectionType!!');
   end;
end;

{ TCustomBorDebugScanner }

constructor TCustomBorDebugScanner.Create(ABorDebug: TBorDebug);
begin
  inherited Create;
  FBorDebug := ABorDebug;
end;

procedure TCustomBorDebugScanner.ScanModuleSegment(const SubSection: TBorDebugSubSection;
                                            Module: TBorDebugModule;
                                            SegmentIndex: integer;
                                      const Segment: TModuleSegment);
begin
 // Do nothing, by default...
end;

procedure TCustomBorDebugScanner.ScanModule(const SubSection: TBorDebugSubSection; Module: TBorDebugModule; var KeepIt: boolean);
var
  i: integer;
  Segment: TModuleSegment;
begin
  for i := 0 to Module.SegmentCount-1 do
  begin
    Segment := Module.Segments[i];
    ScanModuleSegment(SubSection, Module, i, Segment);
  end;
end;

procedure TCustomBorDebugScanner.ScanSymbolTypeInfo(const SubSection: TBorDebugSubSection; SymbolInfo: TSymbolInfo; TypeInfo: TTypeInfo; var KeepIt: boolean);
begin
  // Do nothing
end;

function TCustomBorDebugScanner.WantType(const BorDebugType: TBorDebugType): boolean;
begin
  // Always look at all types, by default...
  Result := True;
end;

function TCustomBorDebugScanner.WantFieldList(const SubSection: TBorDebugSubSection; SymbolInfo: TSymbolInfo; const BorDebugType: TBorDebugType): boolean;
begin
  // Always look at all field lists, by default...
  Result := True;
end;

function TCustomBorDebugScanner.WantTypeInfoForSymbol(SymbolInfo: TSymbolInfo; TypeIndex : TTypeIndex): boolean;
begin
  // Always look at the type of all symbols, by default...
  Result := True;
end;


procedure TCustomBorDebugScanner.ScanSymbolTypeNode(const SubSection: TBorDebugSubSection; SymbolInfo: TSymbolInfo; BorDebugType: TBorDebugType);
var
  TypeInfo: TTypeInfo;
  KeepIt: boolean;
begin
  if WantType(BorDebugType) then
  begin
    KeepIt := False;
    TypeInfo := BorDebug.CreateTypeInfo(BorDebugType);
    try
      ScanSymbolTypeInfo(SubSection, SymbolInfo, TypeInfo, KeepIt);
    finally
      if not KeepIt then
        TypeInfo.Free;
    end;
  end;
end;

procedure TCustomBorDebugScanner.StartFieldListScan(const SubSection: TBorDebugSubSection; SymbolInfo: TSymbolInfo; BorDebugType: TBorDebugType);
begin
  // Do nothing
end;

procedure TCustomBorDebugScanner.EndFieldListScan(const SubSection: TBorDebugSubSection; SymbolInfo: TSymbolInfo; BorDebugType: TBorDebugType);
begin
  // Do nothing
end;

procedure TCustomBorDebugScanner.ScanSymbolTypeTree(const SubSection: TBorDebugSubSection; SymbolInfo: TSymbolInfo; TypeIndex: TTypeIndex);
var
  BorDebugType : TBorDebugType;
  NextTypeIndex : TTypeIndex;
begin
  BorDebugType := BorDebug.TypeFromIndex[TypeIndex];
  ScanSymbolTypeNode(SubSection, SymbolInfo, BorDebugType);
  with BorDebugType do
  begin
    // special case!!
    if (TypeKind = BORDEBUG_LF_FIELDLIST) and
       WantFieldList(SubSection, SymbolInfo, BorDebugType) then
    begin
      StartFieldListScan(SubSection, SymbolInfo, BorDebugType);
      // start the field list
      BorDebugTypeStartFIELDLIST(BorDebug.Handle, TypeOffset);
      while True do
      begin
        // next field
        BorDebugTypeNextFIELDLIST(BorDebug.Handle, TypeKind, TypeOffset);

        // are we done?
        if (TypeKind = 0) and (TypeOffset = 0) then
          Break;

        // is this a continuation?
        if  (TypeKind = BORDEBUG_LF_INDEX) then
        begin
          // get the continuation index and its offset
          NextTypeIndex := BorDebugTypeINDEX(BorDebug.Handle, TypeOffset);
          BorDebugTypeFromIndex(BorDebug.Handle, NextTypeIndex, TypeOffset, Length, TypeKind);

          // continue in the next field list
          BorDebugTypeStartFIELDLIST(BorDebug.Handle, TypeOffset);
          Continue;
        end;

        // Call Tree here??
        ScanSymbolTypeNode(SubSection, SymbolInfo, BorDebugType);
      end;
      EndFieldListScan(SubSection, SymbolInfo, BorDebugType);
    end;
  end;
end;

procedure TCustomBorDebugScanner.ScanSymbolInfo(const SubSection: TBorDebugSubSection; SymbolInfo: TSymbolInfo; var KeepIt: boolean);
var
  TypeIndex : TTypeIndex;
begin
  if SymbolInfo.GetTypeIndex(TypeIndex) and WantTypeInfoForSymbol(SymbolInfo, TypeIndex) then
    ScanSymbolTypeTree(SubSection, SymbolInfo, TypeIndex);
end;

function TCustomBorDebugScanner.WantSymbol(const Symbol: TBorDebugSymbol): boolean;
begin
  // Always look at all symbols, by default...
  Result := True;
end;

procedure TCustomBorDebugScanner.ScanSymbols(const SubSection: TBorDebugSubSection);
var
  Symbol: TBorDebugSymbol;
  SymbolInfo: TSymbolInfo;
  KeepIt: boolean;
begin
  BorDebug.StartSymbols(SubSection);
  while BorDebug.GetNextSymbol(Symbol) do
    if WantSymbol(Symbol) then
    begin
      KeepIt := False;
      SymbolInfo := BorDebug.CreateSymbolInfo(Symbol);
      try
        ScanSymbolInfo(SubSection, SymbolInfo, KeepIt);
      finally
        if not KeepIt then
          SymbolInfo.Free;
      end;
    end;
end;

procedure TCustomBorDebugScanner.ScanSrcModuleRange(const SubSection: TBorDebugSubSection;
                                             SrcModule: TBorDebugSrcModule;
                                             RangeIndex: integer;
                                             RangeSegmentIndex: TSegmentIndex;
                                             RangeStart: TSegmentOffset;
                                             RangeEnd: TSegmentOffset);
begin
  // Do nothing, by default...
end;

procedure TCustomBorDebugScanner.ScanLineNumberOffset(
  LineNumber: TLineNumber;
  LineOffset: TSegmentOffset);
begin
  // Do nothing, by default...
end;

procedure TCustomBorDebugScanner.ScanSrcModuleSourceRange(
  RangeIndex: integer;
  Segment: TSegmentIndex;
  Starts: TSegmentOffset;
  Ends: TSegmentOffset;
  LineNumberCount: TItemCount;
  LineNumberOffsets: TLineNumberOffsets);
var
  i: integer;
begin
  FCurrentLineNumberOffsets := LineNumberOffsets;
  for i := 0 to LineNumberCount-1 do
    with LineNumberOffsets do
      ScanLineNumberOffset(LineNumbers^[i], LineOffsets^[i]);
end;

procedure TCustomBorDebugScanner.ScanSrcModuleSource(const SubSection: TBorDebugSubSection;
                                              SrcModule: TBorDebugSrcModule;
                                              SourceIndex: integer;
                                              SourceOffset: TFileOffset;
                                              NameIndex: TNameIndex;
                                              RangeCount: TItemCount;
                                              SourceFileEntry: TSourceFileEntry);
var
  i: integer;
begin
  FCurrentSourceFileEntry := SourceFileEntry;
  for i := 0 to RangeCount-1 do
    with SourceFileEntry do
    begin
      ScanSrcModuleSourceRange(i, RangeSegments^[i],
                                  RangeSegmentStarts^[i],
                                  RangeSegmentEnds^[i],
                                  LineNumberCounts^[i],
                                  TLineNumberOffsets(LineNumerOffsetList.List^[i]));
   end;
end;

procedure TCustomBorDebugScanner.ScanSrcModule(const SubSection: TBorDebugSubSection; SrcModule: TBorDebugSrcModule; var KeepIt: boolean);
var
  i: integer;
begin
  if soSrcModuleRanges in ScanningOptions then
    with SrcModule do
      for i := 0 to RangeCount-1 do
        ScanSrcModuleRange(SubSection, SrcModule, i, RangeSegments^[i],
                                                     RangeSegmentStarts^[i],
                                                     RangeSegmentEnds^[i]);
  if soSrcModuleFiles in ScanningOptions then
    with SrcModule do
      for i := 0 to SrcModule.SourceCount-1 do
        ScanSrcModuleSource(SubSection, SrcModule, i, SourceOffsets^[i],
                                                      NameIndices^[i],
                                                      RangeCounts^[i],
                                     TSourceFileEntry(SourceFileList.List^[i]));
end;

procedure TCustomBorDebugScanner.ScanSubSection(SubSectionIndex: integer; const SubSection: TBorDebugSubSection);
var
  KeepIt: boolean;
begin
  FCurrentSubSection := @SubSection;
  if SubsectionTypeToScanningOption(SubSection.SubsectionType) in ScanningOptions then
  begin
    KeepIt := False;
    case SubSection.SubsectionType of
      BORDEBUG_SSTMODULE      :
        begin
          FCurrentModule := BorDebug.CreateModule(SubSection);
          try
            ScanModule(SubSection, FCurrentModule, KeepIt);
          finally
            if not KeepIt then
              FreeAndNil(FCurrentModule);
          end;
        end;
      BORDEBUG_SSTGLOBALSYM,
      BORDEBUG_SSTGLOBALPUB,
      BORDEBUG_SSTALIGNSYM    : ScanSymbols(SubSection);
      BORDEBUG_SSTSRCMODULE   :
        begin
          FCurrentSrcModule := BorDebug.CreateSrcModule(SubSection);
          try
            ScanSrcModule(SubSection, FCurrentSrcModule, KeepIt);
          finally
            if not KeepIt then
              FreeAndNil(FCurrentSrcModule);
          end;
        end;
      BORDEBUG_SSTGLOBALTYPES : ;
      BORDEBUG_SSTNAMES       : ;
      BORDEBUG_SSTBROWSE      : ;
    end;
  end;
end;

procedure TCustomBorDebugScanner.ScanSubsections;
var
  i : integer;
begin
  for i := 0 to BorDebug.SubSectionCount-1 do
    ScanSubSection(i, BorDebug.SubSections[i]);
end;

procedure TCustomBorDebugScanner.Scan(ScanningOptions: TScanningOptions);
begin
  FScanningOptions := ScanningOptions;
  BorDebug.Active := True;
  ScanSubsections;
end;

{ TLineNumberScanner }

procedure TLineNumberScanner.ScanLineNumberOffset(LineNumber: TLineNumber; LineOffset: TSegmentOffset);
begin
  case FTask of
    ltMatchAddress :
      begin
        if (LineOffset <= FAddress) and (LineOffset > FBestMatch) then
        begin
          FBestMatch := LineOffset;
          FFoundMatch := True;
          FLinenumber := Linenumber;
          // TODO: Improvement; limit to source modules that have the right range!
          FUnitName := FCurrentSourceFileEntry.Name;
        end;
      end;
    stMatchUnitLinenr:
      ; // Not implemented yet...
  end;
end;

function TLineNumberScanner.FindUnitnameLinenumber(Address: TSegmentOffset;
  out Unitname: string; out Linenumber: TLinenumber): boolean;
begin
  FTask := ltMatchAddress;
  FAddress := Address;
  FFoundMatch := false;
  FBestMatch := 0;
  Scan([soSrcModule, soSrcModuleFiles]);
  Result := FFoundMatch;
  if Result then
  begin
    Unitname := FUnitname;
    Linenumber := FLinenumber;
  end;
end;

end.